home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / codegen / interp.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  14.1 KB  |  389 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. structure Interp : sig val interp : Lambda.lexp -> 'a end = struct
  3.  
  4. open Array List Access Types Lambda ErrorMsg
  5. infix 9 sub
  6. structure U = System.Unsafe
  7. val cast = U.cast
  8. datatype 'a env = BIND of 'a env * lvar * 'a
  9.  
  10. val MTENV : 'a env = cast()
  11.  
  12. fun realc s =
  13.   let val (sign,s) = case explode s of "~"::rest => (~1.0,rest) | s => (1.0,s)
  14.       fun j(exp,d::dl,mant) = j(exp,dl,mant * 0.1 + real(d))
  15.         | j(0,nil,mant) = mant*sign
  16.         | j(exp,nil,mant) = if exp>0 then j(exp-1,nil,mant*10.0)
  17.                      else j(exp+1,nil,mant*0.1)
  18.       fun h(esign,wholedigits,diglist,exp,nil) = 
  19.             j(esign*exp+wholedigits-1,diglist,0.0)
  20.         | h(es,fd,dl,exp,d::s) = h(es,fd,dl,exp*10+(ord d - ord "0"),s)
  21.       fun g(i,r,"E"::"~"::s)=h(~1,i,r,0,s)
  22.     | g(i,r,"E"::s)=h(1,i,r,0,s)
  23.     | g(i,r,d::s) = g(i, (ord d - ord "0")::r, s)
  24.     | g(i,r,nil) = h(1,i,r,0,nil)
  25.       fun f(i,r,"."::s)=g(i,r,s)
  26.         | f(i,r,s as "E"::_)=g(i,r,s)
  27.         | f(i,r,d::s) = f(i+1,(ord(d)-ord("0"))::r,s)
  28.    in f(0,nil,s)
  29.   end
  30.  
  31. fun look v =
  32.  let fun f(BIND(e,w,x)) = if v=w then x else f e
  33.   in f
  34.  end
  35.  
  36. val upd = BIND
  37.  
  38.  val rec M = 
  39.    fn APP(FN(v,_,b),a) => let val a' = M a and b' = M b
  40.                            in fn r => cast(b' (upd(r,v, cast (a' r))))
  41.                           end
  42.     | APP(a,b) => cast let val a' = cast(M a) and b' = M b
  43.                    in fn r => cast((a' r) (b' r))
  44.                   end
  45.     | FN(v,_,b) => let val b' = M b
  46.                     in fn r => cast (fn x =>  b' (upd(r,v,x)))
  47.                    end
  48.     | DECON((_,UNTAGGED,_),b) => let val b' = cast(M b)
  49.                               in fn r => let val {x} = (cast(b' r))
  50.                                   in x
  51.                          end
  52.                   end
  53.     | DECON((_,TAGGED _,_),b) => let val b' = cast(M b)
  54.                               in fn r => cast(U.subscript(b' r, 1))
  55.                  end
  56.     | DECON((_,TAGGEDREC(_,1),_),b) => 
  57.             let val b' = M b
  58.          in fn r => let val (i,x) = cast(b' r)
  59.                      in cast{x=x} 
  60.             end
  61.         end
  62.     | DECON((_,TAGGEDREC(_,2),_),b) => 
  63.             let val b' = M b
  64.          in fn r => let val (i,x,y) = cast(b' r)
  65.                      in cast(x,y)
  66.             end
  67.         end
  68.     | DECON((_,TAGGEDREC(_,3),_),b) => 
  69.             let val b' = M b
  70.          in fn r => let val (i,x,y,z) = cast(b' r)
  71.              in cast(x,y,z)
  72.                 end
  73.         end
  74.     | DECON((_,TAGGEDREC(_,4),_),b) => 
  75.             let val b' = M b
  76.          in fn r => let val (i,w,x,y,z) = cast(b' r)
  77.               in cast(w,x,y,z)
  78.             end
  79.         end
  80.     | DECON((_,TAGGEDREC(_,5),_),b) => 
  81.             let val b' = M b
  82.          in fn r => let val (i,v,w,x,y,z) = cast(b' r)
  83.              in cast(v,w,x,y,z)
  84.             end
  85.         end
  86.     | DECON((_,TAGGEDREC(_,j),_),b) => 
  87.             let val b' = M b
  88.             fun f(z,n) = if n=j then nil
  89.                      else U.subscript(z,j+1)::f(z,n+1)
  90.          in fn r => cast(Vector.vector(f(cast(b' r),0)))
  91.         end
  92.     | DECON((_,UNTAGGEDREC _,_),b) => M b
  93.     | DECON((_,VARIABLE _,_),b) => let val b' = cast(M b)
  94.                                 in fn r => cast(U.subscript(b' r, 1))
  95.                      end
  96.     | DECON((_, TRANSPARENT,_),b) => M b
  97.     | CON((_,UNTAGGED,_),b) => let val b' = M b
  98.                             in fn r => cast {a= b' r}
  99.                    end
  100.     | CON((_,CONSTANT i,_),b) => (fn r => cast i)
  101.     | CON((_,TAGGED i,_),b) => let val b' = M b
  102.                             in fn r => cast (i, b' r)
  103.                    end
  104.     | CON((_,VARIABLE(PATH p),_),b) => 
  105.                      let val b' = M b
  106.                  fun g [v] = VAR v
  107.                    | g (i::r) = SELECT(i, g r)
  108.                  val gp = M(g p)
  109.               in fn r => cast (gp r, b' r)
  110.              end
  111.     | CON((_,VARIABLEc(PATH p),_),_) => 
  112.              let fun g [v] = VAR v
  113.                    | g (i::r) = SELECT(i, g r)
  114.               in M(g p)
  115.              end
  116.     | CON((_,TRANSPARENT,_),b) => M b
  117.     | CON((_,TAGGEDREC(i,1),_),b) => 
  118.             let val b' = M b
  119.          in fn r => let val {1=x} = cast(b' r)
  120.                         in cast(i,x)
  121.                 end        
  122.             end
  123.     | CON((_,TAGGEDREC(i,2),_),b) => 
  124.             let val b' = M b
  125.          in fn r => let val (x,y) = cast(b' r)
  126.              in cast(i,x,y)
  127.             end         
  128.             end
  129.     | CON((_,TAGGEDREC(i,3),_),b) => 
  130.             let val b' = M b
  131.          in fn r => let val (x,y,z) = cast(b' r)
  132.              in cast(i,x,y,z)
  133.             end        
  134.             end
  135.     | CON((_,TAGGEDREC(i,4),_),b) => 
  136.             let val b' = M b
  137.          in fn r => let val (w,x,y,z) = cast(b' r)
  138.              in cast(i,w,x,y,z)
  139.             end         
  140.             end
  141.     | CON((_,TAGGEDREC(i,5),_),b) => 
  142.             let val b' = M b
  143.          in fn r => let val (v,w,x,y,z) = cast(b' r)
  144.                      in cast(i,v,w,x,y,z)
  145.             end         
  146.             end
  147.     | CON((_,TAGGEDREC(i,j),_),b) => 
  148.             let val b' = M b
  149.             fun f(z,n) = if n=j then nil
  150.                  else U.subscript(z,n)::f(z,n+1)
  151.          in fn r => cast(Vector.vector(i::f(cast(b' r),0)))
  152.         end
  153.     | CON((_,UNTAGGEDREC _,_),b) => M b
  154.     | SELECT(i,a) => let val a' = cast(M a) 
  155.               in fn r => cast(U.subscript(a' r, i))
  156.              end
  157.     | RECORD [] => (fn r => cast())
  158.     | RECORD [a,b] => let val a' = M a and b' = M b
  159.                in fn r => cast (a' r, b' r)
  160.               end
  161.     | RECORD [a,b,c] => let val a' = M a and b' = M b and c' = M c
  162.                  in fn r => cast (a' r, b' r, c' r)
  163.                 end
  164.     | RECORD [a,b,c,d] => let val a' = M a and b' = M b
  165.                   and c' = M c and d' = M d
  166.                    in fn r => cast (a' r, b' r, c' r, d' r)
  167.                   end
  168.     | RECORD [a,b,c,d,e] => let val a' = M a and b' = M b
  169.                     and c' = M c and d' = M d
  170.                     and e' = M e
  171.                      in fn r => cast (a' r, b' r, c' r, d' r, e' r)
  172.                     end
  173.     | RECORD [a,b,c,d,e,f] => let val a' = M a and b' = M b
  174.                       and c' = M c and d' = M d
  175.                       and e' = M e and f' = M f
  176.                        in fn r => cast (a' r, b' r, c' r, d' r, 
  177.                                                 e' r, f' r)
  178.                       end
  179.     | RECORD l => let val l' = map M l
  180.            in fn r => cast(Vector.vector(map (fn x => x r) l'))
  181.           end
  182.     | VECTOR [] => (fn r => cast())
  183.     | VECTOR [a,b] => let val a' = M a and b' = M b
  184.                in fn r => cast(Vector.vector[a' r, b' r])
  185.               end
  186.     | VECTOR [a,b,c] => let val a' = M a and b' = M b and c' = M c
  187.                  in fn r => cast (a' r, b' r, c' r)
  188.                 end
  189.     | VECTOR [a,b,c,d] => let val a' = M a and b' = M b
  190.                   and c' = M c and d' = M d
  191.                    in fn r => cast (a' r, b' r, c' r, d' r)
  192.                   end
  193.     | VECTOR [a,b,c,d,e] => let val a' = M a and b' = M b
  194.                     and c' = M c and d' = M d
  195.                     and e' = M e
  196.                      in fn r => cast (a' r, b' r, c' r, d' r, e' r)
  197.                     end
  198.     | VECTOR [a,b,c,d,e,f] => let val a' = M a and b' = M b
  199.                       and c' = M c and d' = M d
  200.                       and e' = M e and f' = M f
  201.                        in fn r => cast (a' r, b' r, c' r, d' r, 
  202.                                                 e' r, f' r)
  203.                       end
  204.     | VECTOR l => let val l' = map M l
  205.            in fn r => cast(Vector.vector(map (fn x => x r) l'))
  206.           end
  207.  
  208.     | INT i => (fn r => cast i)
  209.     | STRING s => (fn r => cast s)
  210.     | REAL s => let val x = realc s in fn r => cast x end
  211.     | PRIM(P.CAST,_) => (fn r => cast(fn x => x))
  212.     | PRIM(P.IADD,_) => (fn r => cast Integer.+)  
  213.     | PRIM(P.ISUB,_) => (fn r => cast Integer.-)
  214.     | PRIM(P.IMUL,_) => (fn r => cast Integer.* )
  215.     | PRIM(P.IDIV,_) => (fn r => cast Integer.div)
  216.     | PRIM(P.ORB,_) => (fn r => cast Bits.orb)
  217.     | PRIM(P.ANDB,_) => (fn r => cast Bits.andb)
  218.     | PRIM(P.XORB,_) => (fn r => cast Bits.xorb)
  219.     | PRIM(P.NOTB,_) => (fn r => cast Bits.notb)
  220.     | PRIM(P.RSHIFT,_) => (fn r => cast Bits.rshift)
  221.     | PRIM(P.LSHIFT,_) => (fn r => cast Bits.lshift)
  222.     | PRIM(P.DEREF,_) => (fn r => cast !)
  223.     | PRIM(P.MAKEREF,_) => (fn r => cast ref)
  224.     | PRIM(P.INEG,_) => (fn r => cast Integer.~)
  225.     | PRIM(P.IEQL,_) => (fn r => cast (fn(a:int,b) => a=b))
  226.     | PRIM(P.INEQ,_) => (fn r => cast (fn(a:int,b) => a<>b))
  227.     | PRIM(P.IGT,_) => (fn r => cast Integer.>)
  228.     | PRIM(P.ILT,_) => (fn r => cast Integer.<)
  229.     | PRIM(P.IGE,_) => (fn r => cast Integer.>=)
  230.     | PRIM(P.ILE,_) => (fn r => cast Integer.<=)
  231.     | PRIM(P.LESSU,_) =>  (* this is buggy if b<0 *)
  232.     (fn r => cast (fn (a, b) => ((0 <= a) andalso (a < b))))
  233.     | PRIM(P.GEQU,_) => (* this is buggy if b<0 *)
  234.     (fn r => cast (fn (a, b) => ((0 > a) orelse (a >= b))))
  235.     | PRIM(P.SUBSCRIPT,_) => (fn r => cast U.subscript)
  236.     | PRIM(P.UPDATE,_) => (fn r => cast U.update)
  237.     | PRIM(P.BOXEDUPDATE,_) => (fn r => cast U.update)
  238.     | PRIM(P.UNBOXEDUPDATE,_) => (fn r => cast U.update)
  239.     | PRIM(P.SUBSCRIPTV,_) => (fn r => cast U.subscriptv)
  240.     | PRIM(P.FSUBSCRIPTd,_) => (fn r => cast U.subscriptf)
  241.     | PRIM(P.FUPDATEd,_) => (fn r => cast U.updatef)
  242.     | PRIM(P.LENGTH,_) => (fn r => cast Array.length)
  243.     | PRIM(P.OBJLENGTH,_) => (fn r => cast U.objLength)
  244.     | PRIM(P.STORE,_) => (fn r => cast U.store)
  245.     | PRIM(P.ORDOF,_) => (fn r => cast U.ordof)
  246.     | PRIM(P.FADDd,_) => (fn r => cast Real.+)
  247.     | PRIM(P.FDIVd,_) => (fn r => cast Real./)
  248.     | PRIM(P.FMULd,_) => (fn r => cast Real.* )
  249.     | PRIM(P.FSUBd,_) => (fn r => cast Real.-)
  250.     | PRIM(P.FNEGd,_) => (fn r => cast Real.~)
  251.     | PRIM(P.FABSd,_) => (fn r => cast Real.abs)
  252.     | PRIM(P.REAL,_) => (fn r => cast Real.real)
  253.     | PRIM(P.FEQLd,_) => (fn r => cast (fn(a:real,b)=>a=b))
  254.     | PRIM(P.FNEQd,_) => (fn r => cast (fn(a:real,b)=>a<>b))
  255.     | PRIM(P.FGTd,_) => (fn r => cast Real.>)
  256.     | PRIM(P.FGEd,_) => (fn r => cast Real.>=)
  257.     | PRIM(P.FLEd,_) => (fn r => cast Real.<=)
  258.     | PRIM(P.FLTd,_) => (fn r => cast Real.<)
  259.     | PRIM(P.BOXED,_) => (fn r => cast U.boxed)
  260.     | PRIM(P.UNBOXED,_) => (fn r => cast (not o U.boxed))
  261.     | PRIM(P.CALLCC,_) => (fn r => cast callcc)
  262.     | PRIM(P.CAPTURE,_) => (fn r => cast U.PolyCont.capture)
  263.     | PRIM(P.THROW,_) => (fn r => cast throw)
  264.     | PRIM(P.GETVAR,_) => (fn r => cast U.getvar)
  265.     | PRIM(P.GETTAG,_) => (fn r => cast U.getObjTag)
  266.     | PRIM(P.MKSPECIAL,_) => (fn r => cast U.special)
  267.     | PRIM(P.SETSPECIAL,_) => (fn r => cast U.setSpecial)
  268.     | PRIM(P.GETSPECIAL,_) => (fn r => cast U.getSpecial)
  269.     | PRIM(P.SETVAR,_) => (fn r => cast U.setvar)
  270.     | PRIM(P.GETHDLR,_) => (fn r => cast U.gethdlr)
  271.     | PRIM(P.SETHDLR,_) => (fn r => cast U.sethdlr)
  272.     | PRIM(p,_) => impossible(implode["bad primop ", 
  273.                               P.pr_primop p, " in interp"])
  274.     | VAR v => look v
  275.     | HANDLE(a,b) => let val a' = cast (M a) and b' = cast(M b)
  276.                       in fn r => (a' r handle e => b' r e)
  277.                      end
  278.     | RAISE(a,_) => let val a' = cast (M a) in fn r => raise(a' r) end
  279.     | FIX(nl,_,fl,b) => 
  280.          let fun g(n::nl,f::fl) = let val f' = M f
  281.                           val fl' = g(nl,fl)
  282.                                    in fn rr => cast (upd(fl' rr,n, 
  283.                         fn x => cast(f'(!rr)) x))
  284.                                   end
  285.                 | g(nil,_) = cast(fn rr => !rr)
  286.              val l = g(nl,fl)
  287.              val b' = cast(M b)
  288.           in fn r => cast (let val rr = ref (cast r)
  289.                     in rr := l (cast rr); b'(!rr)
  290.                            end)
  291.          end
  292.    | SWITCH(e,_,l as (DATAcon(_,VARIABLE _,_), _)::_, SOME d) => exnswitch(e,l,d)
  293.    | SWITCH(e,_,l as (DATAcon(_,VARIABLEc _,_),_)::_, SOME d) => exnswitch(e,l,d)
  294.    | SWITCH(e,_,l as (REALcon _, _)::_, SOME d) =>
  295.      let fun trans(REALcon i, a)= (realc i, M a)
  296.          val cases = map trans l and d' = M d and e' = M e
  297.      in fn r => cast (let val e'':real = cast(e' r)
  298.             fun find ((i, answer)::rest) =
  299.              if i=e'' then answer r else find rest
  300.                   | find nil = d' r
  301.          in find cases
  302.         end)
  303.      end
  304.    | SWITCH(e,_,l as (INTcon _, _)::_, SOME d) =>
  305.      let fun trans(INTcon i, a)= (i, M a)
  306.          val cases = map trans l and d' = M d and e' = M e
  307.      in fn r => cast (let val e'':int = cast(e' r)
  308.             fun find ((i, answer)::rest) =
  309.              if i=e'' then answer r else find rest
  310.                   | find nil = d' r
  311.          in find cases
  312.         end)
  313.      end
  314.    | SWITCH(e,_,l as (STRINGcon _, _)::_, SOME d) =>
  315.      let fun trans(STRINGcon i, a)= (i, M a)
  316.          val cases = map trans l and d' = M d and e' = M e
  317.      in fn r => cast(let val e'':string = cast(e' r)
  318.             fun find ((i, answer)::rest) =
  319.              if i=e'' then answer r else find rest
  320.                   | find nil = d' r
  321.          in find cases
  322.         end)
  323.      end
  324.    | SWITCH(e,_, l as (DATAcon _, _)::_, d) =>
  325.      let val d' = case d of SOME d0 => M d0
  326.                           | NONE => fn r =>  impossible "no default in interp"
  327.          val e' = M e
  328.          fun f((DATAcon(_,CONSTANT i,_),ans)::rest) =
  329.         let val rest' = f rest
  330.             val ans' = M ans
  331.              in fn x => if x=i then ans' else rest' x
  332.         end
  333.            | f((DATAcon(_,TAGGED i,_),ans)::rest) =
  334.         let val rest' = f rest
  335.             val ans' = M ans
  336.              in fn x => if U.boxed x andalso U.subscript(cast x,0)=i 
  337.                 then ans' else rest' x
  338.         end
  339.            | f((DATAcon(_,TAGGEDREC(i,_),_),ans)::rest) =
  340.         let val rest' = f rest
  341.             val ans' = M ans
  342.              in fn x => if U.boxed x andalso U.subscript(cast x,0)=i 
  343.                 then ans' else rest' x
  344.         end
  345.            | f((DATAcon(_,UNTAGGED,_),ans)::rest) =
  346.         let val rest' = f rest
  347.             val ans' = M ans
  348.              in fn x => if U.boxed x then ans' else rest' x
  349.         end
  350.            | f((DATAcon(_,UNTAGGEDREC _,_),ans)::rest) =
  351.         let val rest' = f rest
  352.             val ans' = M ans
  353.              in fn x => if U.boxed x then ans' else rest' x
  354.         end
  355.            | f((DATAcon(_,TRANSPARENT,_),ans)::rest) =
  356.         let val rest' = f rest
  357.             val ans' = M ans
  358.              in fn x => if U.boxed x
  359.                 then ans' else rest' x
  360.         end
  361.            | f nil = fn x => d'
  362.      val cases = f l
  363.      in fn r => cases(e' r) r
  364.      end
  365.    | WRAP(t,e) => M e
  366.    | UNWRAP(t,e) => M e
  367.    | _ => impossible "bad lexp in interp"
  368.  
  369.  and exnswitch = fn (e,l,d) =>
  370.      let fun trans(DATAcon(_,VARIABLEc(PATH p),_), a)=
  371.         (rev(0::p), M a)
  372.            | trans(DATAcon(_,VARIABLE(PATH p),_), a)=
  373.         (rev p, M a)
  374.          val cases = map trans l and d' = M d and e' = M e
  375.      in fn r => cast(let val e'' : int = U.subscript(cast(e' r),0)
  376.             fun select(x,i::rest) = select(U.subscript(cast x,i),rest)
  377.               | select(x,nil) = cast x
  378.             fun find ((v::path, answer)::rest) =
  379.              if select(look v r,path)=e'' then answer r
  380.                 else find rest
  381.                   | find nil = d' r
  382.          in find cases
  383.         end)
  384.      end
  385.  
  386.  fun interp lexp = cast(M lexp MTENV)
  387.  
  388. end (* structure Interp *)
  389.